{-
    BNF Converter: ocamlyacc Generator
    Copyright (C) 2005  Author:  Kristofer Johannisson

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA
-}

-- based on BNFC Haskell backend

{-# LANGUAGE LambdaCase #-}

module BNFC.Backend.OCaml.CFtoOCamlYacc
       (
       cf2ocamlyacc, terminal, epName
       )
        where

import BNFC.CF
import Data.List (intersperse,nub)
import Data.Char

import BNFC.Utils ((+++))
import BNFC.Backend.OCaml.OCamlUtil

-- Type declarations

type Pattern     = String
type Action      = String
type MetaVar     = String

-- The main function, that given a CF
-- generates a ocamlyacc module.
cf2ocamlyacc :: String -> String -> String -> CF -> String
cf2ocamlyacc name absName lexName cf
 = unlines
    [header name absName lexName cf,
    declarations absName cf,
    "%%",
    rules cf
    ]


header :: String -> String -> String -> CF -> String
header _ absName _ cf = unlines
         ["/* This ocamlyacc file was machine-generated by the BNF converter */",
          "%{",
          "open " ++ absName,
          "open Lexing",
          "",
          definedRules cf,
          "%}"
         ]

definedRules :: CF -> String
definedRules cf = unlines [ mkDef f xs e | FunDef f xs e <- cfgPragmas cf ]
  where
    mkDef f xs e = "let " ++ f ++ " " ++ mkTuple xs ++ " = " ++ ocamlExp e

    ocamlExp :: Exp -> String
    ocamlExp = \case
      Var s       -> s
      App s es    -> s ++ ' ' : mkTuple (map ocamlExp es)
      LitInt i    -> show i
      LitDouble d -> show d
      LitChar c   -> "\'" ++ c : "\'"
      LitString s -> "\"" ++ s ++ "\""

declarations :: String -> CF -> String
declarations absName cf = unlines
    [tokens (cfgSymbols cf) (reservedWords cf),
     specialTokens cf,
     entryPoints absName cf
    ]

tokens :: [String] -> [String] -> String
tokens symbols reswords = unlines
    [
        if not (null reswords)
            then "%token" +++ concat (intersperse " " (map ("KW_" ++) reswords))
        else ""
        ,
        concatMap (\(s,n) -> "\n%token SYMB" ++ (show n) +++ "/*" +++ s +++ "*/")
            (zip symbols [1..])
    ]

-- | map a CF terminal into a ocamlyacc token
terminal :: CF -> String -> String
terminal cf s  |  s `elem` reservedWords cf = "KW_" ++ s
terminal cf s  = case lookup s (zip (cfgSymbols cf) [1..]) of
    Just i -> "SYMB" ++ show i
    Nothing -> error $ "CFtoOCamlYacc: terminal " ++ show s ++ " not defined in CF."


-- | map a CF nonterminal into a ocamlyacc symbol
nonterminal :: Cat -> String
nonterminal c = map spaceToUnderscore (fixType c)
    where spaceToUnderscore ' ' = '_'
          spaceToUnderscore x = x

specialTokens :: CF -> String
specialTokens cf = unlines . ("%token TOK_EOF" :) $
  map (\ n -> "%token" +++ aux n +++ "TOK_" ++ n) $ nub $ specialCatsP ++ literals cf
  where
  aux = \case
    "Ident"   -> "<string>"
    "String"  -> "<string>"
    "Integer" -> "<int>"
    "Double"  -> "<float>"
    "Char"    -> "<char>"
    _         -> "<string>"

entryPoints :: String -> CF -> String
entryPoints absName cf = unlines $
    ("%start" +++
        concat (intersperse " " (map epName eps)))
    :
    (map typing eps)
    where eps = allEntryPoints cf
          typing :: Cat -> String
          typing c = "%type" +++ "<" ++ qualify (normCat c) ++ ">" +++ epName c
          qualify c = if c `elem` [ TokenCat "Integer", TokenCat "Double", TokenCat "Char",
                                    TokenCat "String", ListCat (TokenCat "Integer"),
                                    ListCat (TokenCat "Double"),
                                    ListCat (TokenCat "Char"),
                                    ListCat (TokenCat "String") ]
                      then fixType c
                      else absName ++ "." ++ fixType c

epName :: Cat -> String
epName c = "p" ++ capitalize (nonterminal c)
            where capitalize s = case s of
                    [] -> []
                    c:cs -> toUpper c : cs

entryPointRules :: CF -> String
entryPointRules cf = unlines $ map mkRule $ allEntryPoints cf
    where
        mkRule :: Cat -> String
        mkRule s = unlines [
            epName s ++ " : " ++ nonterminal s ++ " TOK_EOF { $1 }",
            "  | error { raise (BNFC_Util.Parse_error (Parsing.symbol_start_pos (), Parsing.symbol_end_pos ())) };"
            ]

rules :: CF -> String
rules cf = unlines [
    entryPointRules cf,
    (unlines $ map (prOne . mkOne) (ruleGroups cf)),
    specialRules cf
    ]
    where
        mkOne (cat,rules) = (cat, constructRule cf rules cat)
        prOne (_,[]) = [] -- nt has only internal use
        prOne (nt,((p,a):ls)) =
          unwords [nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ ";\n"
         where
           nt' = nonterminal nt
           pr [] = []
           pr ((p,a):ls) =
             unlines [(concat $ intersperse " " ["  |", p, "{", a , "}"])] ++ pr ls



-- For every non-terminal, we construct a set of rules. A rule is a sequence of
-- terminals and non-terminals, and an action to be performed
constructRule :: CF -> [Rule] -> NonTerminal -> [(Pattern,Action)]
constructRule cf rules nt =
  [ (p, generateAction nt (funRule r) m)
  | r <- rules
  , let (p, m) = generatePatterns cf r
  ]



-- Generates a string containing the semantic action.
-- An action can for example be: Sum $1 $2, that is, construct an AST
-- with the constructor Sum applied to the two metavariables $1 and $2.
generateAction :: NonTerminal -> Fun -> [MetaVar] -> Action
generateAction _ f ms = (if isCoercion f then "" else f') +++ mkTuple ms
    where f' = case f of -- ocaml cons is somehow not a standard infix oper, right?
                    "(:[])" -> "(fun x -> [x])"
                    "(:)" -> "(fun (x,xs) -> x::xs)"
                    _ -> f


generatePatterns :: CF -> Rule -> (Pattern,[MetaVar])
generatePatterns cf r = case rhsRule r of
  []  -> ("/* empty */",[])
  its -> (unwords (map mkIt its), metas its)
 where
   mkIt i = case i of
     Left c -> nonterminal c
     Right s -> terminal cf s
   metas its = [ ('$': show i) | (i, Left _c) <- zip [1 ::Int ..] its ]

specialRules :: CF -> String
specialRules cf = unlines $ (`map` literals cf) $ \case
  "Ident"   -> "ident : TOK_Ident  { Ident $1 };"
  "String"  -> "string : TOK_String { $1 };"
  "Integer" -> "int :  TOK_Integer  { $1 };"
  "Double"  -> "float : TOK_Double  { $1 };"
  "Char"    -> "char : TOK_Char { $1 };"
  own       -> concat $
    [ fixType (TokenCat own), " : TOK_", own, " { ", own, " (",  posn, "$1)};" ]
    where -- ignore position categories for now
    posn = "" -- if isPositionCat cf own then "mkPosToken " else ""
